home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / grprim.lisp < prev    next >
Text File  |  1993-07-17  |  7KB  |  242 lines
  1. ';; -*- Mode:LISP; Package:BOXER; Base:10.;fonts:cptfont; -*-
  2. ;;
  3. ;; Copyright 1984 Massachusetts Institute of Technology
  4. ;;
  5. ;; Permission to use, copy, modify, distribute, and sell this software
  6. ;; and its documentation for any purpose is hereby granted without fee,
  7. ;; provided that the above copyright notice appear in all copies and that
  8. ;; both that copyright notice and this permission notice appear in
  9. ;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;; advertising or publicity pertaining to distribution of the software
  11. ;; without specific, written prior permission.  M.I.T. makes no
  12. ;; representations about the suitability of this software for any
  13. ;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;
  15. ;;
  16. ;;                          +-Data--+
  17. ;; This file is part of the | BOXER | system
  18. ;;                          +-------+
  19. ;;
  20. ;; This file contains all of the boxer functions which use the graphics subsystem
  21.  
  22. ;;; Graphics functions for graphics boxes
  23.  
  24.  
  25.  
  26.  
  27. (defboxer-function bu:wrap ()
  28.   (tell (graphics-box-near (box-being-told))
  29.     :set-draw-mode :wrap)
  30.   :noprint)
  31.  
  32. ; fence should be fixed before this command is implemented.
  33. ;(defboxer-function bu:fence ()
  34. ;  (tell (graphics-box-near (box-being-told))
  35. ;    :set-draw-mode :fence)
  36. ;  :noprint)
  37.  
  38. (defboxer-function bu:window ()
  39.   (tell (graphics-box-near (box-being-told))
  40.     :set-draw-mode :window)
  41.   :noprint)
  42.  
  43. ;;; Graphics functions for Objects (especially turtles)
  44.  
  45. ;;; This next subst directs a message to the appropriate turtle
  46. ;;;It replaces the magic-naming stuff in the old implementation
  47.  
  48. (defsubst tell-named-sprite (message &rest args)
  49.   (let* ((sprite-box (sprite-box-near (box-being-told)))
  50.      (turtle (tell-check-nil sprite-box :associated-turtle)))
  51.     (cond ((null turtle) (ferror "Use TELL to execute turtle commands outside a sprite box"))
  52.       ((null (tell turtle :assoc-graphics-box))
  53.        (ferror "Sprite is not in a Graphics Box"))
  54.       (t (lexpr-send turtle message args)))))
  55.  
  56.  
  57. (defboxer-function bu:cs ()
  58.   (let ((graphics-box (graphics-box-near (box-being-told))))
  59.     (tell-check-nil graphics-box :clearscreen)))
  60.  
  61. (DEFBOXER-FUNCTION BU:CLEARSCREEN ()
  62.   (let ((graphics-box (graphics-box-near (box-being-told))))
  63.     (tell-check-nil graphics-box :clearscreen)))
  64.  
  65. (DEFBOXER-FUNCTION BU:FD ((NUMBERIZE STEPS))
  66.  (TELL-named-sprite :FORWARD STEPS))
  67.  
  68. (DEFBOXER-FUNCTION BU:FORWARD ((NUMBERIZE STEPS))
  69.   (TELL-named-sprite :FORWARD STEPS))
  70.  
  71. (DEFBOXER-FUNCTION BU:BK ((NUMBERIZE STEPS))
  72.   (TELL-named-sprite :FORWARD (- STEPS)))
  73.  
  74. (DEFBOXER-FUNCTION BU:BACK ((NUMBERIZE STEPS))
  75.   (TELL-named-sprite :FORWARD (- STEPS)))
  76.  
  77. (DEFBOXER-FUNCTION BU:RT ((NUMBERIZE TURNS))
  78.   (tell-named-sprite :right TURNS))
  79.  
  80. (DEFBOXER-FUNCTION BU:RIGHT ((NUMBERIZE TURNS))
  81.   (tell-named-sprite :right turns))
  82.  
  83. (DEFBOXER-FUNCTION BU:LT ((NUMBERIZE TURNS))
  84.   (tell-named-sprite :right (- TURNS)))
  85.  
  86. (DEFBOXER-FUNCTION BU:LEFT ((NUMBERIZE TURNS))
  87.   (tell-named-sprite :right (- TURNS)))
  88.  
  89. (DEFBOXER-FUNCTION BU:PU ()
  90.   (TELL-named-sprite :set-pen 'up) ':NOPRINT)
  91.  
  92. (DEFBOXER-FUNCTION SETXY ((NUMBERIZE X) (NUMBERIZE Y))
  93.   (tell-named-sprite :MOVE-TO X Y))
  94.  
  95. ;;; home 
  96. (defboxer-function bu:go-home ()
  97.   (tell-named-sprite :go-home))
  98.  
  99. (defboxer-function bu:home ()
  100.   (tell-named-sprite :go-home))
  101.  
  102. (DEFBOXER-FUNCTION BU:PENUP ()
  103.   (TELL-NAMED-SPRITE :set-pen 'up) ':NOPRINT)
  104.  
  105. (DEFBOXER-FUNCTION BU:PD ()
  106.   (TELL-NAMED-SPRITE :set-pen 'down) ':NOPRINT)
  107.  
  108. (DEFBOXER-FUNCTION BU:PENDOWN ()
  109.   (TELL-NAMED-SPRITE :set-pen 'down) ':noprint)
  110.  
  111. (DEFBOXER-FUNCTION BU:PE ()
  112.   (TELL-NAMED-SPRITE :set-pen 'erase) ':noprint)
  113.  
  114. (DEFBOXER-FUNCTION BU:PENERASE ()
  115.   (TELL-NAMED-SPRITE :set-pen 'erase) ':noprint)
  116.  
  117. (DEFBOXER-FUNCTION BU:PENXOR ()
  118.   (TELL-NAMED-SPRITE :set-pen 'xor) ':noprint)
  119.  
  120. (DEFBOXER-FUNCTION BU:PENREVERSE ()
  121.   (TELL-NAMED-SPRITE :set-pen 'xor) ':noprint) 
  122.  
  123. (DEFBOXER-FUNCTION BU:PX ()
  124.   (TELL-NAMED-SPRITE :set-pen 'xor) ':noprint)
  125.  
  126. (DEFBOXER-FUNCTION BU:HIDE ()
  127.   (TELL-NAMED-SPRITE :HIDE-TURTLE) ':NOPRINT)
  128.  
  129. (DEFBOXER-FUNCTION BU:HIDETURTLE ()
  130.   (TELL-NAMED-SPRITE :HIDE-TURTLE) ':NOPRINT)
  131.  
  132. (DEFBOXER-FUNCTION BU:HT ()
  133.   (TELL-NAMED-SPRITE :HIDE-TURTLE) ':NOPRINT)
  134.  
  135. (DEFBOXER-FUNCTION BU:SHOW ()
  136.   (TELL-NAMED-SPRITE :SHOW-TURTLE) ':NOPRINT)
  137.  
  138. (DEFBOXER-FUNCTION BU:SHOWTURTLE ()
  139.   (TELL-NAMED-SPRITE :SHOW-TURTLE) ':NOPRINT)
  140.  
  141. (DEFBOXER-FUNCTION BU:ST ()
  142.   (TELL-NAMED-SPRITE :SHOW-TURTLE) ':NOPRINT)
  143.  
  144. (DEFBOXER-FUNCTION BU:TOWARDS ((NUMBERIZE X) (NUMBERIZE Y))
  145.   (TELL-NAMED-SPRITE :TOWARDS X Y))
  146.  
  147. (DEFBOXER-FUNCTION BU:SET-SCRUNCH ((NUMBERIZE NEW-SCRUNCH))
  148.   (SETQ *SCRUNCH-FACTOR* NEW-SCRUNCH)
  149.   :noprint)
  150.  
  151. (defboxer-function bu:flash-name ()
  152.   (tell-named-sprite :flash-name)
  153.   ':NOPRINT)
  154.  
  155. (defboxer-function bu:type ((PORTIFY BOX))
  156.   (tell-named-sprite
  157.     :type-box (GET-PORT-TARGET box))
  158.   ':noprint)
  159.  
  160. (defboxer-function bu:follow-mouse ()
  161.   (tell-named-sprite :usurp-mouse))
  162.  
  163. (defboxer-function bu:stamp ()
  164.   (tell-named-sprite :stamp))
  165.  
  166. (defboxer-function bu:copy-self ()
  167.   (copy-box (sprite-box-near (box-being-told)) nil))
  168.  
  169. (defboxer-function bu:rotate (angle)
  170.   (tell-named-sprite :rotate (numberize angle))
  171.   ':noprint)
  172.  
  173. (defboxer-function bu:ss ()
  174.   (tell-named-sprite :set-shown-p :subsprites)
  175.   :noprint)
  176.  
  177. (defboxer-function bu:sn ()
  178.   (tell-named-sprite :set-shown-p :no-subsprites)
  179.   :noprint)
  180.  
  181. (defboxer-function bu:touching? (sprite-b)
  182.   (when (port-box? sprite-b) (setq sprite-b (tell sprite-b :ports)))
  183.   (boxify
  184.     (if 
  185.       (tell-named-sprite :touching? (tell sprite-b :associated-turtle))
  186.       'bu:true
  187.       'bu:false)))
  188.  
  189. (defboxer-function bu:single-touching-sprite ()
  190.   (let ((turtle (tell-named-sprite :sprite-under)))
  191.     (if (turtle? turtle)
  192.     (boxify (port-to-internal (tell turtle :sprite-box)))
  193.     (make-box nil))))
  194.  
  195. (defboxer-function bu:all-touching-sprites ()
  196.   (let ((turtles (tell-named-sprite :all-sprites-in-contact))
  197.      sprites)
  198.     (dolist (turtle turtles)
  199.       (setq sprites (cons (port-to-internal (tell turtle :sprite-box))
  200.               sprites)))
  201.     (make-box (list sprites))))
  202.  
  203. (defboxer-function bu:enclosing-rectangle ()
  204.   (multiple-value-bind (Left top right bottom)
  205.         (tell-named-sprite :enclosing-rectangle)
  206.     (make-box (list (list left top) (list right bottom)))))
  207.  
  208. (defboxer-function bu:change-xy (xpos ypos)
  209.   (tell-named-sprite :move-to (numberize xpos) (numberize ypos)))
  210.  
  211. ;;; included for compatibility because I changed the name
  212. (defboxer-function bu:single-touched-sprite ()
  213.   (let ((turtle (tell-named-sprite :sprite-under)))
  214.     (if (turtle? turtle)
  215.     (boxify (port-to-internal (tell turtle :sprite-box)))
  216.     (make-box nil))))
  217.  
  218. (defboxer-function bu:all-touched-sprites ()
  219.   (let ((turtles (tell-named-sprite :all-sprites-in-contact))
  220.      sprites)
  221.     (dolist (turtle turtles)
  222.       (setq sprites (cons (port-to-internal (tell turtle :sprite-box))
  223.               sprites)))
  224.     (make-box (list sprites))))
  225.  
  226. ;(DEFBOXER-FUNCTION BU:COMPLEMENT (GRAPHICS-BOX)
  227. ;  (WHEN (GRAPHICS-BOX? GRAPHICS-BOX)
  228. ;    (TELL GRAPHICS-BOX :COMPLEMENT)
  229. ;    (REDISPLAY-BOX GRAPHICS-BOX)))
  230. ;
  231. ;(DEFBOXER-FUNCTION BU:COPY-CONTENTS (FROM-GBOX TO-GBOX)
  232. ;  (TELL TO-GBOX :FILL-FROM-GRAPHICS-BOX FROM-GBOX)
  233. ;  (REDISPLAY-BOX TO-GBOX))
  234. ;
  235. ;(DEFBOXER-FUNCTION BU:PLACE-CONTENTS-AT (FROM-GBOX TO-GBOX X Y)
  236. ;  (TELL TO-GBOX :PLACE-STAMP-WITH-CLIPPING FROM-GBOX X Y)
  237. ;  (REDISPLAY-BOX TO-GBOX))
  238.  
  239. ;(DEFBOXER-FUNCTION BU:DESCRIBE (GRAPHICS-OBJECT)
  240. ;  (MAKE-BOX (TELL GRAPHICS-OBJECT :DESCRIPTION-LIST)))
  241.  
  242.